{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  WumpusLite.Picture
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  unstable
-- Portability :  GHC
--
-- Re-thinking Wumpus...
--
--------------------------------------------------------------------------------

module WumpusLite.Picture
  (

  
    Point2(..)
  , Vec2(..)
  , DPoint2
  , DVec2
  , PathStyle(..)
  , PrimName
  , Graphic(..)
  , PathSeg(..)
  , AffineTrafo(..)
  , GS_Command(..)
  , PostScript
  , outputPS

  ) where


import WumpusLite.Colour
import WumpusLite.Geometry
import WumpusLite.GraphicProps

-- import Data.Fixed


type PSFloat = Decimal

-- Note - there is a techinique for code size efficient 
-- CLOSED_FILL_STROKE... See MJ Rutter\'s eps slides.
--
data PathStyle = OPEN_STROKE | CLOSED_STROKE | CLOSED_FILL | CLOSED_STROKE_FILL
  deriving (Enum,Eq,Ord,Show)

type PrimName = String

data Graphic = Text     DPoint2     String
             | PrimCall PrimName    DPoint2 [PSFloat]
             | Path     PathStyle   DPoint2 [PathSeg]
             | Cat      Graphic     Graphic
             | Trafo    AffineTrafo Graphic
  deriving (Show)




-- | Relative...
--
data PathSeg = CurveTo DVec2 DVec2 DVec2
             | LineTo DVec2
  deriving (Eq,Ord,Show)


data GS_Command = FillColour   RGBi
                | StrokeColour RGBi
                | LineWidth    Decimal
                | LineCap      LineCap
                | LineJoin     LineJoin
  deriving (Eq,Show)


-- | For Pictures - Affine transformations are represented as 
-- /syntax/ so they can be manipulated easily.
--
data AffineTrafo = Matrix   DMatrix3'3
                 | Rotate   Radian
                 | RotAbout Radian      DPoint2
                 | Scale    Decimal     Decimal
                 | Traslate Decimal     Decimal
  deriving (Eq,Show)


data ProcVal = Float Decimal
             | Char  Char
             | String String
  deriving (Eq,Show)


-- | Numerical arguments must have defaults.
--
data Proc = Proc 

data ProcStmt = MoveStart DVec2     ProcStmt
              | ProcText  String
              | ProcPath  PathStyle DPoint2  [PathSeg]
              | Seq       ProcStmt  ProcStmt
              | ProcCall  String    [ProcVal]
  deriving (Eq,Show)

type PostScript = String

outputPS :: Graphic -> PostScript
outputPS gfx = prologue ++ "\n" ++ genPS gfx


prologue :: PostScript
prologue = unlines $ 
    [ "% Font load"
    , "/FL   % SZ NAME FL"
    , "{"
    , "  findfont exch"
    , "  scalefont"
    , "  setfont"
    , "} bind def"
    , ""
    , "% Stroked circle"
    , "/SCIRC     % X Y R SCIRC"
    , "{"
    , "  /R exch def"
    , "  /Y  exch def"
    , "  /X  exch def"
    , "  newpath"
    , "  X Y R 0.0 360.0 arc"
    , "  closepath"
    , "  stroke"
    , "} bind def"
    ]


genPS :: Graphic -> PostScript
genPS (Text ogin s)                 = 
    unlines [ "12 /Helvetica FL", moveTo ogin, "(" ++ s ++ ") show"]

genPS (PrimCall s (P2 x y) args)    = invoke s (x:y:args) 

genPS (Path sty ogin segs)          = 
    unlines [ "newpath", moveTo ogin , drawSegs segs, drawPath sty ]

genPS (Cat g1 g2)                   = unlines [ genPS g1, genPS g2 ]

genPS (Trafo traf g)                = 
    let cmd = trafo traf in unlines [ "gsave", cmd, genPS g, "grestore" ]



moveTo :: DPoint2 -> PostScript
moveTo (P2 x y) = 
    unwords [ truncateDecimal x, truncateDecimal y, "moveto" ]

drawSegs :: [PathSeg] -> PostScript
drawSegs = unlines . map drawSeg

drawSeg :: PathSeg -> PostScript
drawSeg (CurveTo (V2 x1 y1) (V2 x2 y2) (V2 x3 y3)) = 
    unwords (map truncateDecimal [x1,y1,x2,y2,x3,y3]) ++ " rcurveto"

drawSeg (LineTo (V2 x1 y1)) = 
    unwords (map truncateDecimal [x1,y1]) ++ " rlineto"

trafo :: AffineTrafo -> PostScript
trafo (Rotate r)  = unwords [ truncateDecimal $ realToFrac $ r2d r, "rotate" ]
trafo (Scale x y) = 
    unwords [ truncateDecimal x, truncateDecimal y, "scale" ]

drawPath :: PathStyle -> PostScript
drawPath OPEN_STROKE    = "stroke"
drawPath CLOSED_STROKE  = unlines ["closepth", "stroke"]
drawPath CLOSED_FILL    = unlines ["closepth", "fill"]


invoke :: String -> [Decimal] -> PostScript
invoke fn args = unwords (map truncateDecimal args) ++ " " ++ fn

--------------------------------------------------------------------------------
-- Helpers


